home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / GRIDS / IMPGRID / IMPGRID.ZIP / IMPGRID.PAS < prev   
Pascal/Delphi Source File  |  1996-10-29  |  10KB  |  319 lines
  1. {$A+,B-,C-,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
  2. {$MINSTACKSIZE $00004000}
  3. {$MAXSTACKSIZE $00100000}
  4. {$IMAGEBASE $00400000}
  5. {$APPTYPE GUI}
  6. unit impgrid;
  7.  
  8. interface
  9.  
  10. uses
  11.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  12.   Grids;
  13.  
  14. type
  15.   Timpgrid = class(TStringGrid)
  16.   private
  17.     FlightColor: tcolor;
  18.     FDarkColor: tcolor;
  19.     FGridLineColor: tcolor;
  20.     FFixedJustify: integer;
  21.     FJustify: integer;
  22.     Foffset: integer;
  23.     FColFontColor: string;
  24.     FFixedFont: tfont;
  25.     FVertLab: boolean;
  26.     procedure setLightColor(value: tcolor);
  27.     procedure setDarkColor(value: tcolor);
  28.     procedure setGridLineColor(value: tcolor);
  29.     procedure setFixedJustify(value: integer);
  30.     procedure setJustify(value: integer);
  31.     procedure setoffset(value: integer);
  32.     procedure setColFontColor(value: string);
  33.     procedure setFixedFont(value: tfont);
  34.     procedure setvertLab(value: boolean);
  35.     { Private declarations }
  36.   protected
  37.     procedure DrawCell(ACol, ARow: longint; ARect: TRect;
  38.               AState: TGridDrawState); override;
  39.     { Protected declarations }
  40.   public
  41.     constructor Create(AOwner: TComponent); override;
  42.     destructor Destroy; override;
  43.  
  44.   published
  45.     property Align;
  46.     property ColCount;
  47.     property DefaultColWidth;
  48.     property DefaultRowHeight;
  49.     property EditorMode;
  50.     property Gridlinewidth;
  51.     property Options;
  52.     property RowCount;
  53.     property ScrollBars;
  54.     property LightColor: tcolor     read FLightColor write setLightColor;         {default $02ffffff; }
  55.     property DarkColor: tcolor      read FDarkColor write setDarkColor;           {default $0280ff80; }
  56.     property GridLineColor: tcolor  read FGridLineColor write setGridLineColor;   {default $0220ff20; }
  57.     property FixedJustify: integer  read FFixedJustify write setFixedJustify;     {default 0;         }
  58.     property Justify: integer       read FJustify write setJustify;               {default 1;         }
  59.     property ColFontColor:string    read FColFontColor write setColFontColor;     {default 'clblack'; }
  60.     property offset: integer        read FOffset write setOffset;                 {default 0;         }
  61.     property FixedFont: tfont       read FFixedFont write setFixedFont;           {default parentfont;}
  62.     property VertLab: boolean       read FVertLab write setVertLab;
  63.     property OnClick;
  64.     property OnColumnMoved;
  65.     property OnDblClick;
  66.     property OnDragDrop;
  67.     property OnDrawCell;
  68.     property OnEnter;
  69.     property OnExit;
  70.     property OnRowMoved;
  71.     property OnTopLeftChanged;
  72.     property OnMouseDown;
  73.     procedure SaveToFile(filename: string);
  74.     procedure LoadFromFile(filename: string);
  75.     procedure SetColColor(col: longint; color: string);
  76.     procedure AddCol;
  77.     procedure FixedFontChanged(Sender: Tobject);
  78.   end;
  79.  
  80.  
  81. procedure Register;
  82.  
  83. implementation
  84.  
  85. constructor timpgrid.Create(AOwner: TComponent);
  86. var i: longint;
  87. begin
  88.   inherited Create(AOwner);  {  call inherited Constructor...   }
  89.   FFixedFont := tFont.create;
  90.   FFixedFont.onchange := FixedFontChanged;
  91.   {temporary}  colfontcolor := 'clblue';
  92.   for i := 0 to Colcount do cells[i,fixedrows] := ColFontColor;
  93. end;
  94.  
  95. destructor timpgrid.Destroy;
  96. begin
  97.   {FFixedFont.free;}
  98.   inherited Destroy;
  99. end;
  100.  
  101. procedure Register;
  102. begin
  103.   RegisterComponents('Additional', [timpgrid]);
  104. end;
  105.  
  106. procedure timpgrid.DrawCell(ACol, ARow: longint; ARect: TRect;
  107.          AState: TGridDrawState);
  108. var
  109.   lfont: TLOGFONT;
  110.   thefont: hfont;
  111.   oldfont: hfont;
  112.   s:pchar;
  113.   clr: tcolor;
  114.   str: string[10];
  115. begin
  116.   canvas.font.assign(font);
  117.   with canvas do
  118.   if (ACol < fixedcols) or (ARow < FixedRows) then  { fixed box... }
  119.   begin
  120.     if vertlab and (ARow = 0) then { vertical labels }
  121.       begin
  122.           begin
  123.             {s := stralloc(12);}
  124.  
  125.             with lfont do
  126.               begin
  127.                 lfHeight:= defaultcolwidth - 8;
  128.                 lfWidth:=5;
  129.                 lfEscapement:= 900; {this is angle}
  130.                 {lfOrientation: Integer; }
  131.                 lfWeight:= {4}500;
  132.                 lfItalic:= 0;
  133.                 lfUnderline:= 0;
  134.                 lfStrikeOut:= 0;
  135.                 {lfCharSet: Byte;}
  136.                 lfOutPrecision:= 255;
  137.                 {lfClipPrecision: Byte;}
  138.                 lfQuality:= 255;
  139.                 {lfPitchAndFamily: Byte;
  140.                 lfFaceName: array[0..lf_FaceSize - 1] of Char;}
  141.                 strpcopy(lffacename,'Times New Roman');
  142.               end;
  143.             canvas.brush.color := Fixedcolor;
  144.             thefont := createfontindirect(lfont);
  145.             oldfont := selectobject(canvas.handle, thefont);
  146.             {str := cells[acol,arow];
  147.             strpcopy(s,str); }
  148.             SetTextColor(canvas.handle,fixedfont.color);  {this needs to be the same color as the rest of the column}
  149.  
  150.             canvas.textout(arect.left+4,arect.bottom-5,cells[acol,arow]);
  151.             {strdispose(s);}
  152.             thefont := selectobject(canvas.handle, oldfont);
  153.             deleteobject(thefont);
  154.           end;
  155.  
  156.       end
  157.     else
  158.     begin
  159.       font := FFixedFont;
  160.       brush.color := FixedColor;
  161.       if fixedjustify = 0 then textrect(arect, arect.left+2
  162.          ,arect.top+2,cells[acol,arow]) { left justify...  }
  163.       else textrect(arect, arect.right-textwidth(cells[acol,arow])-3
  164.        ,arect.top+2,cells[acol,arow]);{ right justify... }
  165.     end;
  166.   end
  167.   else                                              { not fixed... }
  168.     begin
  169.                                                  { determine brush color... }
  170.       if (trunc((trunc((arow+offset)/4+0.0001))*4) = arow+offset)
  171.                              or
  172.          (trunc((trunc((arow-1+offset)/4+0.0001))*4) = arow-1+offset) then
  173.                brush.color := lightcolor
  174.           else brush.color := darkcolor;
  175.       try
  176.         font.color := stringtocolor(colfontcolor){stringtocolor(cells[acol,fixedrows])};          { set font color }
  177.       except
  178.         on EConvertError do font.color := clblack;
  179.       end;
  180.       if justify = 0 then textrect(arect, arect.left+2
  181.          ,arect.top+2,cells[acol,arow]) { left justify...  }
  182.       else textrect(arect, arect.right-textwidth(cells[acol,arow])-3
  183.        ,arect.top+2,cells[acol,arow]);{ right justify... }
  184.     end;
  185. end;
  186.  
  187. procedure timpgrid.SetColColor(col: longint; color: string);
  188. begin
  189.     {cells[col,fixedrows] := color; }
  190. end;
  191.  
  192. procedure timpgrid.SaveToFile(filename: string);
  193. var i,j: integer;
  194.     f:   textfile;
  195. begin
  196.   {open file for output...}
  197.   assignfile(f,filename);
  198.   rewrite(f);  {reset for output...}
  199.   {add header}
  200.   writeln(f,'Don Morris Improved Grid File');
  201.   writeln(f,'Do < NOT > mess with this!!!');
  202.   writeln(f,colcount);
  203.   writeln(f,rowcount);
  204.   for i := 0 to colcount do
  205.     for j := 0 to rowcount do
  206.       writeln(f,cells[i,j]);    {write in all the grades...}
  207.   writeln(f,'yes it is a long file in text format.');
  208.   writeln(f, 'Tamper with it and lose it!!!');
  209.   closefile(f);
  210. end;
  211.  
  212. procedure timpgrid.LoadFromFile(filename: string);
  213. var i,j,cols,rows: integer;
  214.     f:   textfile;
  215.     cell: string;
  216. begin
  217.   {open file for input...}
  218.   assignfile(f,filename);
  219.   reset(f);  {reset for input...}
  220.   {add header}
  221.   readln(f{,'Don Morris Improved Grid File'});
  222.   readln(f{,'Do < NOT > mess with this!!!'});
  223.   readln(f,cols);
  224.     colcount := cols;
  225.   readln(f,rows);
  226.     rowcount := rows;
  227.   for i := 0 to colcount do
  228.     for j := 0 to rowcount do
  229.       begin
  230.         readln(f,cell);    {write in all the grades...}
  231.         cells[i,j] := cell;
  232.       end;
  233.   {last two lines ignored}
  234.   closefile(f);
  235. end;
  236.  
  237. procedure timpgrid.AddCol;
  238. begin
  239.   colcount := colcount +1;
  240.   cells[colcount,fixedrows] := colfontcolor;  { new font color default is black... }
  241. end;
  242.  
  243. {set new properties...}
  244.  
  245.     procedure timpgrid.setvertlab(value: boolean);
  246.     begin
  247.       if Fvertlab <> value then
  248.         begin
  249.           Fvertlab := value;
  250.           Invalidate;
  251.         end;
  252.       end;
  253.     procedure timpgrid.setLightColor(value: tcolor);
  254.     begin
  255.       if FLightColor <> value then
  256.         begin
  257.           FLightColor := value;
  258.           Invalidate;
  259.         end;
  260.       end;
  261.     procedure timpgrid.setDarkColor(value: tcolor);
  262.     begin
  263.       if FDarkColor <> value then
  264.         begin
  265.           FDarkColor := value;
  266.           Invalidate;
  267.         end;
  268.       end;
  269.     procedure timpgrid.setGridLineColor(value: tcolor);
  270.     begin
  271.       if FGridLineColor <> value then
  272.         begin
  273.           FGridLineColor := value;
  274.           Invalidate;
  275.         end;
  276.       end;
  277.     procedure timpgrid.setFixedJustify(value: integer);
  278.     begin
  279.       if FFixedJustify <> value then
  280.         begin
  281.           FFixedJustify := value;
  282.           Invalidate;
  283.         end;
  284.       end;
  285.     procedure timpgrid.setJustify(value: integer);
  286.     begin
  287.       if FJustify <> value then
  288.         begin
  289.           FJustify := value;
  290.           Invalidate;
  291.         end;
  292.       end;
  293.     procedure timpgrid.setoffset(value: integer);
  294.     begin
  295.       if Foffset <> value then
  296.         begin
  297.           Foffset := value;
  298.           Invalidate;
  299.         end;
  300.       end;
  301.     procedure timpgrid.setColFontColor(value: string);
  302.     begin
  303.       if FColFontColor <> value then
  304.         begin
  305.           FColFontColor := value;
  306.           Invalidate;
  307.         end;
  308.       end;
  309.     procedure timpgrid.setFixedFont(value: tfont);
  310.       begin
  311.           FFixedFont.assign(value);
  312.       end;
  313.   procedure timpgrid.FixedFontchanged(Sender: Tobject);
  314.     begin
  315.       Invalidate;
  316.     end;
  317.  
  318. end.
  319.